perm filename CAREYO.SAI[GEO,BGB] blob
sn#013173 filedate 1972-11-18 generic text, type T, neo UTF8
00100 BEGIN "CAREYE-3 - CART'S EYE THREE - AUGUST 1972"
00200
00300 REQUIRE "ABBREV" SOURCE_FILE;
00400 REQUIRE "DPYIII" SOURCE_FILE;
00500 REQUIRE "SAITRG" SOURCE_FILE;
00600
00700 α TELETYPE COMMAND STATE;
00800 ITG CHR,CTRL,META,LETT,αβ,BRK,FLG;
00900 STRING STR;
01000
01100 α DEFINITIONS;
01200
01300 DEFINE mm = "3.2808@-3";
01400 DEFINE PPIOT="'702000000000";
01500 DEFINE THRICE="FOR I←1 STEP 1 UNTIL 3 DO";
01600 DEFINE PUSH= "PADPDL[PDLPTR←PDLPTR+1]";
01700 DEFINE POP = "PADPDL[1+(PDLPTR←PDLPTR-1)]";
01800 DEFINE TOP = "PADPDL[PDLPTR]";
01900 DEFINE ARG1= "PADPDL[PDLPTR-1]";
02000 DEFINE ARG2= "PADPDL[PDLPTR-2]";
02100 DEFINE INCREM(I)="I←I+1";
02200 DEFINE DECREM(I)="I←I-1";
02300 DEFINE XSUBR="EXTERNAL SIMPLE PROCEDURE";
02400
02500 INTERNAL ITG ARRAY PADPDL[0:1000];
02600 INTERNAL ITG PDLPTR,CUT,DEL;
02700
02800 INTERNAL SAFE ITG ARRAY HEADER[0:9];
02900 INTERNAL SAFE ITG ARRAY TVBUF [0:10367];
03000
03100 INTERNAL SAFE ITG ARRAY PAC [0:1727];
03200 SAFE ITG ARRAY DPYBUF[1:5000];
03300 INTERNAL SAFE ITG ARRAY HISTO[-1:64];
03400
03500 α SOURCE WINDOW CENTER;
03600 ITG SX,SY;
03700 REAL SOX,SOY;
03800 α OBJECT WINDOW;
03900 REAL OX,OY,MAG;
04000 α PSEUDO BEAM POSITION;
04100 REAL XXX,YYY;
04200 EXTERNAL SUBR CLIPIN (REAL XL,XH,YL,YH);
04300 EXTERNAL BOOLEAN SUBR CLIP (REFERENCE REAL X1,Y1,X2,Y2);
04400 REAL QQQ;
04500 ITG BRTMIN,VBMIN;
00100 α ABBREVIATIONS FOR PROCEDURE DECLARATIONS;
00200 DEFINE XISUBR= "EXTERNAL INTEGER SIMPLE PROCEDURE";
00300 DEFINE XRSUBR= "EXTERNAL REAL SIMPLE PROCEDURE";
00400 DEFINE XSUBR = "EXTERNAL SIMPLE PROCEDURE";
00500 DEFINE ISUBR = "INTEGER SIMPLE PROCEDURE";
00600 DEFINE RSUBR = "REAL SIMPLE PROCEDURE";
00700 DEFINE BSUBR = "BOOLEAN SIMPLE PROCEDURE";
00800
00900 α YE OLDE MNEMONICS;
01000 ISUBR LAC (ITG Q); START_CODE MOVE 1,@Q END;
01100 RSUBR LACR(ITG Q); START_CODE MOVE 1,@Q END;
01200 ISUBR CAR (ITG Q); START_CODE HLRZ 1,@Q END;
01300 ISUBR CDR (ITG Q); START_CODE HRRZ 1,@Q END;
01400 SUBR DAC (ITG N,Q); START_CODE MOVE N; MOVEM @Q END;
01500 SUBR DACR(REAL X;ITG Q);START_CODE MOVE X;MOVEM @Q END;
01600 SUBR DIP (ITG N,Q); START_CODE MOVE N; HRLM @Q END;
01700 SUBR DAP (ITG N,Q); START_CODE MOVE N; HRRM @Q END;
01800 ISUBR NIP (ITG Q); START_CODE HLRE 1,@Q END;
01900 ISUBR NAP (ITG Q); START_CODE HRRE 1,@Q END;
02000 DEFINE INCREM(A)="A←A+1";
02100 DEFINE DECREM(A)="A←A-1";
02200
02300 α FATAL MESSAGE;
02400 SUBR FATAL (STRING S);
02500 ⊂ OUTSTR(↓&"FATAL ERROR - "&S&↓);
02600 WHILE TRUE DO INCHRW ⊃;
02700 α UBFEV NUMBER;
02800 ISUBR ITYPE (ITG X);
02900 RETURN(CASE(CAR(X)LAND '17)OF
03000 (0,1,2,0, 3,0,0,0, 4,0,0,0, 0,0,0,0));
03100 α ENTITY TYPES;
03200 BSUBR BTYPE(ITG X); RETURN((CAR(X)LAND 1)≠0);
03300 BSUBR FTYPE(ITG X); RETURN((CAR(X)LAND 2)≠0);
03400 BSUBR ETYPE(ITG X); RETURN((CAR(X)LAND 4)≠0);
03500 BSUBR VTYPE(ITG X); RETURN((CAR(X)LAND 8)≠0);
03600 α WORLD CONTEXT;
03700 EXTERNAL ITG WORLD,BTOTAL,FTOTAL,ETOTAL,VTOTAL;
00100 SUBR INITIALIZATION;
00200 BEGIN
00300 VBMIN ← 5;
00400 S⊂ PPIOT 2,-300;PPIOT 3,'2002;⊃;
00500 ⊂ ITG I;FOR I←1 TO 20 DO OUTSTR(↓);⊃;
00600 OUTCHR("o");
00700 END;
00800
00900 SUBR AI(REAL X,Y);⊂ XXX←X*MAG+SOX;YYY←Y*MAG+SOY;⊃;
01000 SUBR AV(REAL X,Y);
01100 BEGIN
01200 REAL X1,Y1,X2,Y2;
01300 X1←XXX;Y1←YYY;X2←XXX←X*MAG+SOX;Y2←YYY←Y*MAG+SOY;
01400 IF CLIP(X1,Y1,X2,Y2) THEN
01500 ⊂ AIVECT(X1,Y1);AVECT(X2,Y2);⊃;
01600 END;
01700
01800 SUBR CROP;
01900 BEGIN "CROP"
02000 REAL OXL,OXH,OYL,OYH;
02100 SOX ← OX - SX*MAG;
02200 SOY ← OY - SY*MAG;
02300 OXL ← (OX - MAG*150*64) MAX -500;
02400 OXH ← (OX + MAG*150*64) MIN 500;
02500 OYL ← (OY - MAG*115*64) MAX -450;
02600 OYH ← (OY + MAG*115*64) MIN 450;
02700 CLIPIN(OXL,OXH,OYL,OYH);
02800 END;
02900
03000 α INPUT A TELEVISION PICTURE;
03100 INTERNAL SUBR TVIN (STRING S);
03200 BEGIN "TVIN"
03300 STRING STR;ITG FLG; LABEL L1,L2;
03400 OPEN(1,"DSK",8,3,0,0,0,0);
03500 STR←S;IF FLG←(LENGTH(STR)=0) THEN GO L2;
03600 L1: LOOKUP(1,STR,FLG);
03700 IF FLG THEN LOOKUP(1,STR&".TMP[DAT,BGB]",FLG);
03800 L2: IF FLG THEN ⊂ OUTSTR(9&"TV FILE = ");
03900 STR←INCHWL;IF LENGTH(STR)=0 THEN RETURN;GO L1;⊃;
04000 ARRYIN(1,HEADER[0],10);
04100 ARRYIN(1,TVBUF[0],10368);
04200 RELEASE(1);
04300 END "TVIN";
04400
04500 ITG X0,Y0,X,Y,I,RC,R,C;
04600 ITG CNT,BUF;
04700 EXTERNAL SUBR PACXOR;
04800 EXTERNAL ITG SUBR MKVIC;
00100 SUBR DPYPGON(ITG P);
00200 BEGIN "DPYPGON"
00300 ITG X,Y,E,E0,V,BRT;
00400
00500 SUBR GETXY(ITG V);
00600 BEGIN "GETXY"
00700 ITG I,J,K,L;
00800 RC←LAC(V-1);
00900 R←RC LSH-18; C←RC LAND '777777;
01000 Y←(108*64-R)*MAG; X←(C-144*64)*MAG;
01100 END "GETXY";
01200
01300 DPYBIG(1);
01400 E←E0←CAR(P+1);V←CAR(E+1);GETXY(V);AI(X,Y);
01500 DO ⊂ BRT ← ABS(NAP(E-1))%2↑3;
01600 V←CDR(E+1);GETXY(V);
01700 IF BRT≥BRTMIN THEN ⊂ DPYBRT(BRT);AV(X,Y);⊃
01800 ELSE AI(X,Y); ⊃ UNTIL (E←CDR(V+1))=E0;
01900 END "DPYPGON";
02000
02100
02200 SUBR REFRESH;
02300 BEGIN "REFRESH"
02400 ITG P,E,E0,V,I,CNT;
02500 DPYSET(DPYBUF);
02600 AIVECT(-500,-450);
02700 AVECT(+500,-450);
02800 AVECT(+500,+450);AVECT(-500,+450);AVECT(-500,-450);
02900 AIVECT(-100,400);DPYBIG(3);DPYSST("CUT = "&CVS(CUT));
03000 FOR I←1 TO PDLPTR DO
03100 BEGIN LABEL L1;
03200 P ← PADPDL[I];
03300 DPYPGON(P);
03400 END;
03500 DPYBIG(1);AIVECT(-511,430);
03600 FOR I←PDLPTR STEP -1 UNTIL (1 MAX (PDLPTR-20)) DO
03700 DPYSST("P"&CVS(PADPDL[I])&↓);
03800 DPYOUT(0);
03900 END "REFRESH";
00100 ITG P2;INTERNAL SUBR DPYXXX;
00200 ⊂ ITG CHR;DPYSET(DPYBUF);DPYPGON(P2);DPYOUT(1);
00300 IF CHR≠'175∧(CHR≠-1) THEN CHR←INCHRW ELSE CHR←INCHRS;⊃;
00400 EXTERNAL ITG FLGXXX;
00500
00600 INTERNAL SUBR MKVICI;
00700 BEGIN "MKVICI"
00800 XISUBR HVCONT(ITG I); α HORIZONTAL-VERTICAL CONTRAST;
00900 XISUBR ARCONT(ITG I); α ARC CONTRAST;
01000 XISUBR MKPAP; XSUBR MKARCS(ITG V1,V2;REAL X);
01100 XSUBR FARCL(ITG PGN); α FIT ARC LINEAR.;
01200 XSUBR KLPGON(ITG I);
01300 ITG P1,V1,V2,E; LABEL L;
01400 SX←SY←0; FLGXXX←META;
01500 MAG ← 7/25; DEL ←25*64;
01600 CROP;
01700 PACXOR;
01800 WHILE (P1←MKVIC)≠0 DO
01900 BEGIN
02000 HVCONT(P1);
02100 CNT ← ABS(LAC(P1-1));
02200 IF CNT≤10 THEN ⊂ KLPGON(P1);CONTINUE;⊃;
02300 α POSSIBLE PRE-MKARCS DISPLAY;
02400 IF CTRL∧ ¬META THEN ⊂ PUSH←P1;REFRESH;RETURN;⊃;
02600 α AD HOC MKARCS CALLING;
02700 P2 ← MKPAP;
02800 E ← CAR(P2+1); V1 ← CAR(E+1); V2 ← CDR(E+1);
02900 MKARCS(V1,V2,QQQ);
03000 MKARCS(V2,V1,QQQ);
03100 IF CHR="N" THEN FARCL(P2);
03200 ARCONT(P2);
03300 KLPGON(P1);
03400 PUSH ← P2;
03500 IF CHR="N" THEN DONE;
03600 END;
03700 REFRESH;
03800 END "MKVICI";
03900
04000 XSUBR THRESH(ITG CUT);
04100 SUBR MKIMAGE;
04200 BEGIN "MKIMAGE"
04300 ITG I;
04400 FOR I←8 STEP 5 UNTIL 60 DO
04500 ⊂ THRESH(I);MKVICI; ⊃;
04600 END "MKIMAGE";
00100 INTERNAL SUBR PLOT;
00200 BEGIN
00300 STRING FILNAM;
00400 INTEGER FLG,CHN;
00500 CHN ← GETCHAN;
00600 OPEN(CHN,"DSK",8,0,3,0,0,0);
00700 DO BEGIN
00800 OUTSTR(13&10&"PLOT FILE = ");
00900 FILNAM ← INCHWL;
01000 ENTER(CHN,FILNAM&".PLT",FLG);
01100 END UNTIL ¬FLG;
01200 ARRYOUT(CHN,DPYBUF[1],DPYBUF[2]);
01300 RELEASE(CHN);
01400 END;
00100 XSUBR HISTOGRAM;
00200 PROCEDURE DPYHISTO;
00300 BEGIN "DPYHISTO"
00400 ITG X,Y;
00500 REAL SX,SY; ITG QMAX,Q,I;
00600 ITG ARRAY DPYBUF[0:300];
00700 DPYSET(DPYBUF);DPYBIG(1);
00800 QMAX ← 0;
00900 FOR I←0 TO 63 DO QMAX ← QMAX MAX HISTO[I];
01000 SY ← 800/QMAX;
01100 SX ← 1024/64;
01200 AIVECT(511,-400);AVECT(-511,-400);
01300 FOR I←0 TO 63 DO
01400 ⊂ Q←HISTO[I];X←I*SX-512;Y←Q*SY-400;
01500 AVECT(X,Y);
01600 IF (I LAND 1) THEN
01700 ⊂ AIVECT(X-8,Y);DPYSST(CVS(I));AIVECT(X,Y);⊃;
01800 AVECT(X+SX,Y);⊃;
01900 AVECT(511,-400);
02000 DPYOUT(6);
02100 HYDPOG(1);HYDPOG(2);HYDPOG(3);HYDPOG(4);
02200 INCHRW;HYDPOG(6);
02300 END "DPYHISTO";
00100 SUBR OUTPGN;
00200 BEGIN "OUTPGN"
00300 ITG X,Y,E,E0,V,P,ECNT;
00400
00500 SUBR GETXY(ITG V);
00600 BEGIN "GETXY"
00700 RC←LAC(V-1);
00800 R←RC LSH-18; C←RC LAND '777777;
00900 Y←(108*64-R)*MAG; X←(C-144*64)*MAG;
01000 END "GETXY";
01100
01200 P ← PADPDL[1];
01300 OPEN(2,"DSK",8,0,3,0,0,0);
01400 ENTER(2,"O.JEG",0);
01500 WORDOUT(2,1);
01600 WORDOUT(2,CUT);
01700
01800 ECNT←0;
01900 E←E0←CAR(P+1);V←CAR(E+1);
02000 DO ⊂ V←CDR(E+1);ECNT←ECNT+1; ⊃ UNTIL (E←CDR(V+1))=E0;
02100 WORDOUT(2,ECNT);
02200 OUTSTR(9&"ECNT = "&CVS(ECNT)&↓);
02300
02400 E←E0←CAR(P+1);V←CAR(E+1);
02500 DO ⊂ V←CDR(E+1);GETXY(V);
02600 WORDOUT(2,X);WORDOUT(2,Y); ⊃ UNTIL (E←CDR(V+1))=E0;
02700 OUTSTR(9&"EOF"&↓);
02800 RELEASE(2);
02900 END;
00100 α CAREYE COMMAND SCANNER - A JUMP TABLE;
00200
00300 INTERNAL PROCEDURE CAREYE;
00400 BEGIN "CAREYE"
00500
00600 OUTSTR(↓&"o");
00700 WHILE TRUE DO
00800 BEGIN "LISTEN"
00900
01000 CHR ← INCHRW;
01100 αβ ← (CHR LSH -7)LAND 3;
01200 CTRL ← CHR LAND '200;
01300 META ← CHR LAND '400;
01400 CHR ← CHR LAND '177;
01500 LETT ← CHR LAND '37;
01600
00100 IF "A"≤CHR ∧ CHR≤"Z" ∨ "a"≤CHR ∧ CHR≤"z" THEN
00200 CASE LETT OF
00300 BEGIN ;
00400 "A" ;
00500 "B" ⊂ STR←INCHWL;BRTMIN←INTSCAN(STR,BRK);REFRESH;OUTSTR("o");⊃;
00600 "C" ⊂ STR←INCHWL;CUT←INTSCAN(STR,BRK);THRESH(CUT);OUTSTR("o");⊃;
00700 "D" ;
00800 "E" ;
00900 "F" ;
01000 "G" ;
01100 "H" ⊂ HISTOGRAM;DPYHISTO;⊃;
01200 "I" ⊂ TVIN(INCHWL);OUTSTR("o");⊃;
01300 "J" ;
01400 "K" ⊂ WHILE PDLPTR≥1 DO
01500 ⊂ XSUBR KLPGON(ITG P);KLPGON(POP);⊃;REFRESH;OUTSTR("o");⊃;
01600 "L" ;
01700 "M" ⊂ MKVICI;OUTSTR(↓&"o");⊃;
01800 "N" ⊂ MKVICI;OUTSTR(↓&"o");⊃;
01900 "O" OUTPGN;
02000 "P" PLOT;
02100 "Q" MKIMAGE;
02200 "R" ;
02300 "S" ⊂ STR←INCHWL;QQQ←REALSCAN(STR,BRK);OUTSTR(9&CVG(QQQ)&↓&"o");⊃;
02400 "T" ;
02500 "U" ;
02600 "V" ⊂ STR←INCHWL;VBMIN←INTSCAN(STR,BRK);REFRESH;OUTSTR("o");⊃;
02700 "W" ;
02800 "X" ;
02900 "Z" ;
03000 END;
03100
03200 IF CHR=13 THEN ⊂ OUTSTR("o");CONTINUE;⊃;
03300 IF CHR=":" THEN SX←SX+DEL ELSE
03400 IF CHR=";" THEN SX←SX-DEL ELSE
03500 IF CHR=")" THEN SY←SY+DEL ELSE
03600 IF CHR="(" THEN SY←SY-DEL ELSE
03700 IF CHR="/" THEN DEL←(DEL%2)MAX 1 ELSE
03800 IF CHR="\" THEN DEL←(DEL*2) ELSE
03900 IF CHR="*" THEN MAG←MAG*2 ELSE
04000 IF CHR="-" THEN MAG←MAG/2 ELSE CONTINUE;
04100 CROP;REFRESH;
04200
04300 END "LISTEN";
04400 END "CAREYE";
04500 QQQ←1.0;
04600 INITIALIZATION;REFRESH;
04700 CAREYE;
04800
04900 END;